home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / format.t < prev    next >
Text File  |  1989-06-30  |  10KB  |  283 lines
  1. (herald format
  2.         (env tsys (osys pool) (osys port_op) (osys port)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;;; Format
  28.  
  29. ;;; for robustness' sake, we put a stub definition of format in
  30. ;;; the kernel.  It jumps here if it thinks the world is in a
  31. ;;; consistent state.
  32.  
  33. (define (t-format-aux port f stuff force?)
  34.   (cond ((eq? port nil)
  35.          (with-output-to-string s (format-internal s f stuff '#f)))
  36.         (else
  37.          (format-internal port f stuff force?))))
  38.  
  39. (define *format-dispatch-table*
  40.   (vector-fill (make-vector number-of-char-codes)
  41.                nil))
  42.  
  43. (define-integrable (format-proc char)
  44.   (vref *format-dispatch-table* (char->ascii char)))
  45.  
  46. (define (set-format-proc char proc)
  47.   (vset *format-dispatch-table* (char->ascii (char-downcase char)) proc)
  48.   (vset *format-dispatch-table* (char->ascii (char-upcase char)) proc))
  49.  
  50. (define (format-internal port f stuff force?)
  51.   (let ((foo (format-internal-loop port f stuff f)))
  52.     (if force? (force-output port))
  53.     (cond ((not (null? foo))
  54.            (error "too many arguments in call to ~s~%  ~s"
  55.                   'format
  56.                   (cons* 'format port f stuff))))
  57.       (no-value)))
  58.  
  59. (define (format-internal-loop port fmt stuff f)
  60.   (cond ((pair? fmt)
  61.          (do ((fmt fmt (cdr fmt))
  62.               (stuff stuff (format-internal-loop port (car fmt) stuff f)))
  63.              ((null-list? fmt) stuff)))
  64.         (else
  65.          (let ((fmt (chopy (enforce string? fmt))))
  66.            (iterate loop ((stuff stuff)) 
  67.              (cond ((string-empty? fmt) stuff)
  68.                    ((char= (char fmt) #\~)
  69.                     (chdr! fmt)
  70.                     (let* ((arg (cond ((or (sign-char? (char fmt))
  71.                                            (digit? (char fmt) 10))
  72.                                        (format-get-number fmt))  ; speed hack (?)
  73.                                       (else nil)))
  74.                            (op (cond ((string-empty? fmt)
  75.                                       (error " bad format string ~%  ~s"
  76.                                              (cons* 'format port f stuff)))
  77.                                      (else (char fmt)))))
  78.                       (chdr! fmt)
  79.                       (let ((proc (format-proc op)))
  80.                         (cond ((null? proc)
  81.                                (error "~c is an unknown code~%  ~s"
  82.                                       op
  83.                                       (cons* 'format port f stuff))
  84.                                (loop stuff))
  85.                               (else (loop (proc port fmt stuff arg)))))))
  86.                    (else
  87.                     (writec port (char fmt))
  88.                     (chdr! fmt)
  89.                     (loop stuff))))))))
  90.  
  91. ;;; gnaw a number off the string.  clobber string header.
  92.  
  93. ;++ this doesn't really work - fix it.
  94.  
  95. (define (format-get-number f)           ; nwm
  96.   (let ((f2 (chopy f)))
  97.     (do ((f f (chdr! f))
  98.          (i 0 (fx+ i 1)))
  99.         ((not (or (sign-char? (char f)) (digit? (char f) 10)))
  100.          (string->integer (string-slice f2 0 i) 10)))))
  101.  
  102. ;;; peel off one object from argument list
  103.  
  104. (define (format-car port fmt stuff)
  105.   (cond ((null? stuff)
  106.          (error "too few arguments in call to ~s~%  (~s ~s ~s ...)"
  107.                 'format 'format
  108.                 port fmt))
  109.         (else (car stuff))))
  110.  
  111. ;;; kludge format: take the next argument as a format string.
  112.  
  113. (define (format-kludge port fmt stuff arg)
  114.   (ignore arg)
  115.   (format-internal-loop port (format-car port fmt stuff) (cdr stuff) fmt))
  116. (set-format-proc #\k format-kludge)
  117.  
  118. ;;; fresh line followed by <arg>-1 newlines
  119.  
  120. (define (format-fresh-line port fmt stuff arg)
  121.   (ignore fmt)
  122.   (fresh-line port)
  123.   (let ((count (if (fixnum? arg) arg 1)))
  124.     (do ((i 1 (fx+ i 1)))
  125.         ((fx>= i count) stuff)
  126.       (newline port))))
  127. (set-format-proc #\& format-fresh-line)
  128.  
  129. ;;; <arg> new lines
  130.  
  131. (define (format-newline port fmt stuff arg)
  132.   (ignore fmt)
  133.   (let ((count (if (fixnum? arg) arg 1)))
  134.     (do ((i 0 (fx+ i 1)))
  135.         ((fx>= i count) stuff)
  136.       (newline port))))
  137. (set-format-proc #\% format-newline)
  138.  
  139. ;;; space over <arg> spaces
  140.  
  141. (define (format-space port fmt stuff arg)
  142.   (ignore fmt)
  143.   (let ((count (if (fixnum? arg) arg 1)))
  144.     (do ((i 0 (fx+ i 1)))
  145.         ((fx>= i count) stuff)
  146.       (space port))))
  147. (set-format-proc #\_ format-space)
  148.  
  149. ;;; tab to column <arg>
  150.  
  151. (define (format-tab port fmt stuff arg)
  152.   (ignore fmt)
  153.   (cond ((fixnum? arg)
  154.          (set-hpos port arg))
  155.         (else
  156.          (writec port #\tab)))
  157.   stuff)
  158. (set-format-proc #\t format-tab)
  159.  
  160. ;;; utility for printing within fixed-width field.
  161.  
  162. (define (format-write-field port width writer)
  163.   (let ((buffer (get-buffer)))
  164.     (writer buffer)
  165.     (let ((count (buffer-length buffer)))
  166.       (cond ((fx>= width 0)
  167.              ;; pad on right.
  168.              (writes port (buffer->string! buffer))
  169.              (if (fx< count width) (vm-write-spaces port (fx- width count))))
  170.             (else
  171.              ;; pad on left.
  172.              (let ((width (fx-negate width)))
  173.                (if (fx< count width) (vm-write-spaces port (fx- width count))))
  174.              (writes port (buffer->string! buffer)))))
  175.     (release-buffer buffer)
  176.     (no-value)))
  177.  
  178. ;;; print
  179.  
  180. (define (format-print port fmt stuff arg)     ; hack field width
  181.   (let ((obj (format-car port fmt stuff)))
  182.     (cond ((fixnum? arg)
  183.            (format-write-field port
  184.                                arg
  185.                                (lambda (port) (print obj port))))
  186.           (else
  187.            (print obj port))))
  188.   (cdr stuff))
  189. (set-format-proc #\s format-print)
  190.  
  191. ;;; display
  192.  
  193. (define (format-display port fmt stuff arg)   ; hack field width
  194.   (let ((obj (format-car port fmt stuff)))
  195.     (cond ((fixnum? arg)
  196.            (format-write-field port
  197.                                arg
  198.                                (lambda (port) (display obj port))))
  199.           (else
  200.            (display obj port))))
  201.   (cdr stuff))
  202. (set-format-proc #\a format-display)
  203.  
  204. ;;; pretty-print
  205.  
  206. (define (format-pretty-print port fmt stuff arg)     ; hack field width
  207.   (ignore arg)
  208.   (let ((obj (format-car port fmt stuff)))
  209.     (pretty-print obj port))
  210.   (cdr stuff))
  211. (set-format-proc #\g format-pretty-print)
  212.  
  213. ;;; pluralize - this is a hack
  214.  
  215. (define (format-plural port fmt stuff arg)
  216.   (ignore arg)
  217.   (let ((obj (enforce number? (format-car port fmt stuff))))
  218.     (if (n= obj 1) (writec port #\s))
  219.     (cdr stuff)))
  220.  
  221. (set-format-proc #\p format-plural)
  222.  
  223. ;;; number in various radices
  224.  
  225. (define (make-radical-formatter radix)
  226.   (lambda (port fmt stuff arg)
  227.     (let ((obj (format-car port fmt stuff)))
  228.       (bind ((*print-table* (rt-with-radix *print-table* radix)))
  229.         (cond ((fixnum? arg)
  230.                (format-write-field port
  231.                                    arg
  232.                                    (lambda (port) (print obj port))))
  233.               (else
  234.                (print obj port))))
  235.       (cdr stuff))))
  236. (set-format-proc #\d (make-radical-formatter 10))
  237. (set-format-proc #\x (make-radical-formatter 16))
  238. (set-format-proc #\o (make-radical-formatter  8))
  239. (set-format-proc #\b (make-radical-formatter  2))
  240.  
  241. ;;; number in radix <arg>
  242.  
  243. (define (format-radical port fmt stuff arg)
  244.   (bind ((*print-table*
  245.       (rt-with-radix *print-table*
  246.              (enforce acceptable-radix? arg))))
  247.     (write port (format-car port fmt stuff))
  248.     (cdr stuff)))
  249. (set-format-proc #\r format-radical)
  250.  
  251. ;;; character
  252.  
  253. (define (format-char port fmt stuff arg)
  254.   (ignore arg)
  255.   (cond ((control? (format-car port fmt stuff))
  256.          (writec port #\^)
  257.          (writec port (uncontrolify (format-car port fmt stuff))))
  258.         (else
  259.          (writec port (format-car port fmt stuff))))
  260.   (cdr stuff))
  261. (set-format-proc #\c format-char)
  262.  
  263. ;;; ~~ prints a tilde
  264.  
  265. (define (format-tilde port fmt stuff arg)
  266.   (ignore fmt arg)
  267.   (writec port #\~)
  268.   stuff)
  269. (set-format-proc #\~ format-tilde)
  270.  
  271. ;;; ~<whitespace> is ignored
  272.  
  273. (define (format-skip-whitespace port fmt stuff arg)
  274.   (ignore port arg)
  275.   (iterate skip ()
  276.     (cond ((whitespace? (char fmt))
  277.            (chdr! fmt) (skip))
  278.           (else stuff))))
  279. (set-format-proc #\linefeed format-skip-whitespace)
  280. (set-format-proc #\return   format-skip-whitespace)
  281. (set-format-proc #\space    format-skip-whitespace)
  282. (set-format-proc #\tab      format-skip-whitespace)
  283.